home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / state.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-06-18  |  5.3 KB  |  228 lines
  1. /* ******************************************************************** */
  2. /* state.c           Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Lisp state                                                   */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: state.c,v 1.6 1992/01/29 13:48:20 pab Exp $
  9.  *
  10.  * $Log: state.c,v $
  11.  * Revision 1.6  1992/01/29  13:48:20  pab
  12.  * additional debug info for sysV
  13.  *
  14.  * Revision 1.5  1992/01/05  22:48:22  pab
  15.  * Minor bug fixes, plus BSD version
  16.  *
  17.  * Revision 1.4  1991/12/22  15:14:35  pab
  18.  * Xmas revision
  19.  *
  20.  * Revision 1.3  1991/11/15  13:45:35  pab
  21.  * copyalloc rev 0.01
  22.  *
  23.  * Revision 1.2  1991/09/11  12:07:42  pab
  24.  * 11/9/91 First Alpha release of modified system
  25.  *
  26.  * Revision 1.1  1991/08/12  16:50:01  pab
  27.  * Initial revision
  28.  *
  29.  * Revision 1.6  1991/02/13  18:25:07  kjp
  30.  * Pass.
  31.  *
  32.  */
  33.  
  34. /*
  35.  * Change Log:
  36.  *   Version 1, May 1990
  37.  */
  38.  
  39. /*
  40.  
  41.  * This holds the "state" data and operations - should be system
  42.  * independant and encapsulte ALL continuation operations...
  43.  
  44.  */
  45.  
  46. #include "funcalls.h"
  47. #include "defs.h"
  48. #include "structs.h"
  49. #include "error.h"
  50. #include "global.h"
  51.  
  52. #include "calls.h"
  53. #include "modboot.h"
  54. #include "allocate.h"
  55. #include "modules.h"
  56.  
  57. #include "state.h"
  58.  
  59. /* Fixed outside of a context switch... */
  60.  
  61. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_current_thread);
  62. SYSTEM_THREAD_SPECIFIC_DECLARATION(int*,state_stack_base);
  63. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject*,state_gc_stack_base);
  64.  
  65. /* Forever wandering... */
  66.  
  67. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject*,state_gc_stack_pointer);
  68. SYSTEM_THREAD_SPECIFIC_DECLARATION(Env,state_dynamic_env);
  69. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_last_continue);
  70. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_handler_stack);
  71.  
  72. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,dp);
  73. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,dlp);
  74.  
  75. /* Notionally, the registers hold the machine state */
  76.  
  77. /*
  78.  * Loads the lisp specific state of the world into a continuation struct
  79.  */
  80.  
  81. LispObject save_state(LispObject *stacktop,LispObject cont)
  82. {
  83. #ifndef NO_DEBUG
  84.   extern int gc_paranoia;
  85.  
  86.   if (gc_paranoia)
  87.     fprintf(stderr,"{Save: 0x%x->0x%x[%d]}",
  88.         SYSTEM_THREAD_SPECIFIC_VALUE(state_gc_stack_base),
  89.         stacktop,(stacktop-SYSTEM_THREAD_SPECIFIC_VALUE(state_gc_stack_base))/sizeof(LispObject));
  90. #endif
  91.   cont->CONTINUE.gc_stack_pointer 
  92.     = stacktop;
  93.  
  94.   cont->CONTINUE.dynamic_env
  95.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_dynamic_env);
  96.  
  97.   cont->CONTINUE.last_continue
  98.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue);
  99.  
  100.   cont->CONTINUE.handler_stack
  101.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_handler_stack);
  102.  
  103.   cont->CONTINUE.dp 
  104.     = SYSTEM_THREAD_SPECIFIC_VALUE(dp);
  105.  
  106.   return(cont);
  107.  
  108. }
  109.  
  110. /*
  111.  * Similarly, the other way around...
  112.  */
  113.  
  114. void change_state(LispObject cont)
  115. {
  116.   
  117.   SYSTEM_THREAD_SPECIFIC_VALUE(state_gc_stack_pointer)
  118.     = cont->CONTINUE.gc_stack_pointer;
  119.  
  120.   SYSTEM_THREAD_SPECIFIC_VALUE(state_dynamic_env)
  121.     = cont->CONTINUE.dynamic_env;
  122.  
  123.   SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue)
  124.     = cont->CONTINUE.last_continue;
  125.  
  126.   SYSTEM_THREAD_SPECIFIC_VALUE(state_handler_stack)
  127.     = cont->CONTINUE.handler_stack;
  128.  
  129.   SYSTEM_THREAD_SPECIFIC_VALUE(dp)
  130.     = cont->CONTINUE.dp;
  131.  
  132.   SYSTEM_THREAD_SPECIFIC_VALUE(dlp)
  133.     = cont->CONTINUE.dp;
  134. }
  135.  
  136. /*
  137.  
  138.  * Set a continuation...
  139.  *
  140.  * Note: these are just the lisp equivalents of setjmp and longjmp -
  141.  *       they do not deal with killing other continuations apart from
  142.  *       themselves or handling unwind protects.
  143.  
  144.  * Note also that all this hackery is required to provide abstraction
  145.  * 'cos were it a standard function call, the stack would get nobbled.
  146.  
  147.  */
  148.  
  149. int set_continue_1(LispObject *stacktop,LispObject cont)
  150. {
  151.  
  152.   cont->CONTINUE.thread = SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread);
  153.  
  154.   save_state(stacktop,cont);
  155.  
  156.   cont->CONTINUE.value = nil;
  157.  
  158.   return(TRUE);
  159.  
  160. }
  161.  
  162. int set_continue_2(LispObject cont)
  163. {
  164.  
  165.   /* Fix last continue... */
  166.  
  167.   LAST_CONTINUE() = cont;
  168.  
  169.   /* All set... */
  170.  
  171.   cont->CONTINUE.live = TRUE;
  172.  
  173.   return(FALSE);
  174.  
  175. }
  176.  
  177. void call_continue(LispObject *stacktop,LispObject cont,LispObject value)
  178. {
  179.   
  180.   if (!is_continue(cont)) {
  181.     printf("****BAD CONTINUATION**** type %d - waiting...\n",typeof(cont));
  182.     fflush(stdout);
  183.     exit(1);
  184.   }
  185.  
  186.   if (cont->CONTINUE.thread 
  187.       != SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread))
  188.     {    
  189.       fprintf(stderr,"Wrong thread: %x[%d] %x[%d]\n",SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread),
  190.           SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread)->THREAD.header.gc,
  191.           cont->CONTINUE.thread,cont->CONTINUE.thread->THREAD.header.gc);
  192.       CallError(stacktop,"call continuation: wrong thread",cont,NONCONTINUABLE);
  193.     }
  194.   cont->CONTINUE.live = FALSE;
  195.  
  196.   /* Already on current thread... */
  197.  
  198.   change_state(cont);
  199.  
  200.   cont->CONTINUE.value = value;
  201.  
  202.   longjmp(cont->CONTINUE.machine_state,TRUE);
  203.  
  204. }
  205.  
  206. /*
  207.  
  208.  * Load a thread into the system ready for execution...
  209.  
  210.  * returns the new GC stacktop
  211.  */
  212.  
  213. LispObject* load_thread(LispObject thread)
  214. {
  215.  
  216.   CURRENT_THREAD() = thread;
  217.  
  218.   STACK_BASE()    = thread->THREAD.stack_base;
  219.   GC_STACK_BASE() = thread->THREAD.gc_stack_base;
  220.   
  221.   /* Just the flexible stuff left... */
  222.  
  223.   change_state(thread->THREAD.state);
  224.  
  225.   return (thread->THREAD.state->CONTINUE.gc_stack_pointer);
  226. }
  227.  
  228.